﻿namespace Lilium

module Pretty =

    open System
    open System.IO

    open Lilium.Prelude

    // Types

    type Doc = 
        | Empty
        | Text of String
        | Beside of (Doc * Doc)
        | Above of Doc * Doc
        | Nest of Doc
        | Merge of (Doc * Doc)

    // Basics

    let private binary f p q = 
        match p, q with
        | Empty, q -> q
        | p, Empty -> p
        | _ -> f p q

    let private binaryEmpty f = binary (fun p q -> f p (f Empty q))

    let above = binary (curry Above)

    let aboveEmpty = binaryEmpty (curry Above)

    let beside = binary (curry Beside)

    let besideEmpty = binaryEmpty (curry Beside)

    let nest p =
        match p with
        | Empty -> Empty
        | _ -> Nest p

    let merge = binaryEmpty (curry Merge)

    let nestAbove p q = above p (nest q)

    let text str = 
        match String.IsNullOrWhiteSpace(str) with 
        | true  -> Empty
        | false -> Text str

    // Operators

    let (<->)  = merge
    let (<+>)  = beside 
    let (<++>) = besideEmpty
    let (</>)  = above 
    let (</!>) = ((>>) nest) << above
    let (<//>) = aboveEmpty
    let (!>)   = nest

    // Predefined documents

    let empty  = Empty
    let semi   = text ";"
    let colon  = text ":"
    let comma  = text ","
    //let space = text " "
    let equals = text "="
    let quote  = text "'"
    let lparen = text "("
    let rparen = text ")"
    let lbrack = text "["
    let rbrack = text "]"
    let lbrace = text "{"
    let rbrace = text "}"

    let plus   = text "+"
    let minus  = text "-"

    // Derivatives

    let joinWith (f : Doc -> Doc -> Doc) (docs : Doc list) = 
        
        let rec joinWith docs cont =
            match docs with 
            | []        -> Empty
            | x::[]     -> cont x
            | x::y::[]  -> cont (f x y)
            | x::xs     -> joinWith xs (fun y -> cont (f x y))

        joinWith docs id

    let puctuation p x y = x <-> p <+> y

    // Rendering

    let render (doc : Doc) (textWriter : TextWriter) =

        let wordSeparator = " "
        let lineSeparator = "\r\n"
        let identDelta = 4
        
        let rec render doc ident newline cont = 
            match doc with 
            | Empty -> cont 0
            | Text str -> 
                match newline with
                | true -> 
                    for i = 1 to ident do textWriter.Write(wordSeparator)
                | false -> ()
                textWriter.Write(str)
                cont 0
            | Beside (p, q) ->
                render p ident newline (fun _ -> textWriter.Write(wordSeparator)
                                                 render q ident false cont)
            | Above (p, q) ->
                render p ident newline (fun _ -> textWriter.Write(lineSeparator)
                                                 render q ident true cont)
            | Nest (p) -> 
                render p (ident + identDelta) newline cont
            | Merge (p, q) ->
                render p ident newline (fun _ -> render q ident false cont)                

        render doc 0 false id |> ignore